/////////////////////////////////////////////////////////////////////////////
// Name:        standardfunctions.cpp
// Author:      Nicolay Giraldo
// Created:     15/04/06
// Copyright:   Nicolay Giraldo
/////////////////////////////////////////////////////////////////////////////

#ifdef __BORLANDC__
    #pragma hdrstop
#endif

#include <wx/wxprec.h>
#ifndef WX_PRECOMP
#  include <wx/wx.h>
#endif

#include <wx/dynarray.h>
#include <wx/regex.h>
#include <wx/datetime.h>

#include <tommath.h>

#include "types.h"
#include "standardfunctions.h"

#include "interpreter.h"

value* type_of (value* expr)
{
	symbol* result = new symbol(_T("null"));
	if (expr)
	{
		switch (expr->getType())
		{
		case t_nil        : result->name.Printf(_T("null"         )); break;
		case t_cons       : result->name.Printf(_T("cons"         )); break;
		case t_function   : result->name.Printf(_T("function"     )); break;
		case t_symbol     : result->name.Printf(_T("symbol"       )); break;
		case t_keyword    : result->name.Printf(_T("keyword"      )); break;
		case t_regexp     : result->name.Printf(_T("regexp"       )); break;
		case t_datetime   : result->name.Printf(_T("date-time"    )); break;
		case t_number     : result->name.Printf(_T("number"       )); break;
		case t_array      : result->name.Printf(_T("array"        )); break;
		case t_string     : result->name.Printf(_T("string"       )); break;
		case t_character  : result->name.Printf(_T("character"    )); break;
		case t_hashtable  : result->name.Printf(_T("hashtable"    )); break;
		case t_package    : result->name.Printf(_T("package"      )); break;
		case t_real       : result->name.Printf(_T("real"         )); break;
		case t_complex    : result->name.Printf(_T("complex"      )); break;
		case t_rational   : result->name.Printf(_T("rational"     )); break;
		case t_floating   : result->name.Printf(_T("floating"     )); break;
		case t_singlefloat: result->name.Printf(_T("single-float" )); break;
		case t_doublefloat: result->name.Printf(_T("double-float" )); break;
		case t_integer    : result->name.Printf(_T("integer"      )); break;
		case t_ratio      : result->name.Printf(_T("ratio"        )); break;
		case t_fixnum     : result->name.Printf(_T("fixnum"       )); break;
		case t_bignum     : result->name.Printf(_T("bignum"       )); break;
		case t_stream     : result->name.Printf(_T("stream"       )); break;
		case t_randomstate: result->name.Printf(_T("random-state" )); break;
		case t_closclass  : result->name.Printf(_T("class"        )); break;
		case t_frame      : result->name.Printf(_T("frame"        )); break;
		case t_thread     : result->name.Printf(_T("thread"       )); break;
		default           : result->name.Printf(_T("internalerror")); break;
		}
	}
	else
	{
		result->name.Printf(_T("null"));
	}
	return result;
}


value* chk_nil(value* exp)
{
	return exp ? exp : new symbol(_("nil")) ;
}


bool chk_type(value* object, type ptype)
{
	if (!object)
	{
		if (ptype == t_value || ptype == t_nilcons || ptype == t_nil || ptype == t_restarg)
		{
			return true;
		}
		return false;
	}
	type objtype = object->getType();
	switch (ptype)
	{
	case t_value         : return true;
	case t_nil           : return false;
	case t_cons          : 
	case t_nilcons       : 
	case t_restarg       : return objtype == t_cons       ;
	case t_function      : return objtype == t_function   ;
	case t_symbol        : return objtype == t_symbol  || objtype == t_keyword ;
	case t_keyword       : return objtype == t_keyword    ;
	case t_regexp        : return objtype == t_regexp     ;
	case t_datetime      : return objtype == t_datetime   ;
	case t_number        : return objtype == t_complex || objtype == t_singlefloat || objtype == t_doublefloat || objtype == t_ratio || objtype == t_fixnum || objtype == t_bignum;
	case t_array         : return objtype == t_datetime   ;
	case t_string        : return objtype == t_string     ;
	case t_character     : return objtype == t_character  ;
	case t_hashtable     : return objtype == t_hashtable  ;
	case t_package       : return objtype == t_package    ;
	case t_real          : return objtype == t_singlefloat || objtype == t_doublefloat || objtype == t_ratio || objtype == t_fixnum || objtype == t_bignum ;
	case t_complex       : return objtype == t_complex    ;
	case t_rational      : return objtype == t_fixnum || objtype == t_bignum || objtype ==  t_ratio ;
	case t_floating      : return objtype == t_singlefloat || objtype == t_doublefloat ;
	case t_singlefloat   : return objtype == t_singlefloat;
	case t_doublefloat   : return objtype == t_doublefloat;
	case t_integer       : return objtype == t_fixnum || objtype == t_bignum;
	case t_ratio         : return objtype == t_ratio      ;
	case t_fixnum        : return objtype == t_fixnum     ;
	case t_bignum        : return objtype == t_bignum     ;
	case t_stream        : return objtype == t_stream     ;
	case t_randomstate   : return objtype == t_randomstate;
	case t_closclass     : return objtype == t_closclass  ;
	case t_frame         : return objtype == t_frame      ;
	case t_thread        : return objtype == t_thread     ;
	case t_internal      : return false                   ;
	}
	return false;
}


value* sum(value* expr)
{
	if (!expr) return new fixnum();
	if (!(chk_type(expr, t_cons) && chk_type(car(expr), t_number)))
	{
		wxLogError(_T("Type error in parameter: %s"), (printstring(expr)).c_str());
		return new fixnum();
	}
	return &((*((number*)car(expr))) + (*((number*)sum(cdr(expr)))));
}


value* sus(value* expr, value* expr2)
{
	if (!expr2) return &( - (*((number*)expr)));
	number& rest = (number&)*(sum(expr2));
	if (!(chk_type(expr, t_number)))
	{
		wxLogError(_T("Type error in parameter: %s"), (printstring(expr)).c_str());
		return NULL;
	}
	return &(((number&)*expr) - rest);
}


value* mul(value* expr)
{
	if (!expr) return new fixnum(1);
	if (!(chk_type(expr, t_cons) && chk_type(car(expr), t_number)))
	{
//		wxLogError(_T("Type error in parameter"));
		wxLogError(_T("Type error in parameter: %s"), (printstring(car(expr))).c_str());
		return  new fixnum(1);
	}
	return &((*((number*)car(expr))) * (*((number*)mul(cdr(expr)))));
}


value* fdiv(value* expr, value* expr2)
{
	if (!expr2) return &((*(new fixnum(1))) / (*((number*)expr)));
	number& rest = (number&)*(mul(expr2));
	if (!(chk_type(expr, t_number)))
	{
		wxLogError(_T("Type error in parameter: %s"), (printstring(expr)).c_str());
		return new fixnum(1);
	}
	return &(((number&)*expr) / rest);
}


value* factorial(value* expr)
{
	bignum* daint;
	if (expr->getType() == t_fixnum)
	{
		daint = new bignum(((fixnum*)expr)->num);
	}
	else
	{
		daint = (bignum*)expr;
	}
	if (daint->num.sign != MP_ZPOS)
	{
		wxLogError(_T("Parameter to function ! (factorial) must be a non-negative integer"));
		return NULL;
	}
	bignum* result = new bignum(1);
	while (daint->num.used > 0)
	{
		mp_mul (&(result->num), &(daint->num), &(result->num));
		mp_sub_d (&(daint->num), (mp_digit) 1, &(daint->num));
		// TODO: this yield is necesary, or, even useful?
//		(wxThread::This())->Yield();
	}
	return &(result->chkmag());
}


int fast_list_length (cons* dcons)
{
	//works only with proper lists (and dotted lists?), for internal use (counting function parameters)
	if (fconsp(dcons))
	{
		value* ncons = cdr(dcons);
		if (fconsp(ncons))
		{
			return 1 + fast_list_length((cons*)ncons);
		}
		else
		{
			return 1;
		}
	}
	else
		return 0;
}


value* list_length (value* dcons)
{
	int n;
	value* fast;
	value* slow;
	for (n = 0, fast = (cons*)dcons, slow = (cons*)dcons; 
	; n+=2)
	{
		// If fast pointer hits the end, return the count.
		if (fendp(fast)) return new fixnum(n);
		if (fast->getType() == t_cons)
		{
			if (fendp(cdr(fast))) return new fixnum(n + 1);
		}
		else
		{
			wxLogError(_T("Type error: %s is not a cons"), (printstring(fast)).c_str());
			return NULL;
		}
		// If fast pointer eventually equals slow pointer,
		//  then we must be stuck in a circular list.
		// (A deeper property is the converse: if we are
		//  stuck in a circular list, then eventually the
		//  fast pointer will equal the slow pointer.
		//  That fact justifies this implementation.)
		if ((fast == slow) && (n > 0)) return NULL;
		
		// As this is C++ we have to make the type checking ourselves
		// otherwise it would be:
		// fast = cdr(cdr(fast)); slow = cdr(slow);
		fast = cdr(fast);
		if (fast->getType() == t_cons)
			fast = cdr(fast);
		else
		{
			wxLogError(_T("Type error: %s is not a cons"), (printstring(fast)).c_str());
			return NULL;
		}
		if (slow->getType() == t_cons)
			slow = cdr(slow);
		else
		{
			wxLogError(_T("Type error: %s is not a cons"), (printstring(slow)).c_str());
			return NULL;
		}
	}
}

value* feval(value* expr)
{
	evalframe eframe;
	eframe.expr = expr;
	eframe.deletable = false;
	interpreter inter;
	inter.eval(&eframe);
	if (eframe.nresults)
	{
		return eframe.result;
	}
	else return NULL;
}
